home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1999 April / macformat-075.iso / Shareware Plus / Applications / Alpha / Tcl / Modes / tclMode.tcl < prev   
Encoding:
Text File  |  1999-01-28  |  32.7 KB  |  1,050 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "tclMode.tcl"
  6.  #                                    created: 5/4/97 {9:31:10 pm} 
  7.  #                                last update: 28/1/1999 {12:58:14 am} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Copyright (c) 1997-1998 Vince Darley
  15.  #  
  16.  #    Three procs from original: Tcl::DblClick listArray, getVarValue
  17.  #    
  18.  #    Adds support for Tk, Itcl keywords and completions, plus 
  19.  #    numerous fixes, improvements and integration with Vince's
  20.  #    Additions.
  21.  # ###################################################################
  22.  ##
  23.  
  24. alpha::mode Tcl 1.7.1 tclMenu {*.tcl *.itcl *.itk} {
  25.     tclMenu electricTab electricReturn electricBraces
  26. } {
  27.     addMenu tclMenu "•269" "Tcl"
  28.     set unixMode(wish) {Tcl}
  29.     set unixMode(tclsh) {Tcl}
  30.     ensureset tclshSig "WIsH"
  31.     ensureset evaluateRemotely 0
  32.     trace variable evaluateRemotely w evaluateRemoteSynchronise
  33. } maintainer {
  34.     "Vince Darley" darley@fas.harvard.edu <http://www.fas.harvard.edu/~darley/>
  35. } uninstall this-file help {
  36.     This mode is for editing Tcl code.  You can edit code for internal
  37.     use with Alpha, or use Alpha as an external editor for code destined
  38.     for use with Tcl and Tk interpreters --- Sun distributes the Wish
  39.     application and a tcl-tk browser plugin.
  40.     
  41.     You can 'evaluate' a procedure (or any Tcl code for that matter) to 
  42.     make changes on the fly.  If you select 'Evaluate Remotely' in the 
  43.     tcl-tk submenu, then such actions will actually send the code
  44.     to a separately running Wish application to be evaluated.
  45. }
  46.  
  47.  
  48. proc tclMenu {} {}
  49.  
  50. # ◊◊◊◊ menu and prefs ◊◊◊◊ #
  51. # The menu.
  52. proc menu::buildtclMenu {} {
  53.     global tclMenu evaluateRemotely
  54.     set ma [list \
  55.       "/-<UswitchToTclsh" \
  56.       [list Menu -n "tcl-tk" -p tcltk::menuProc [list \
  57.       "![lindex {{ } •} $evaluateRemotely]evaluateRemotely" \
  58.       executeCommand]] \
  59.       "(-" "/L<O<BreloadProc" "/I<O<BreformatProc" \
  60.       "/Z<O<BtraceThisProc" "/Z<O<UtraceTclProc…" \
  61.       "/D<O<UdumpTraces" "(-" "rebuildTclIndices" "(-" \
  62.       "<U/PfindProcDefinition…" "/Q<IquickFindProc…" "getVarValue…" \
  63.       "insertMenuCodes…" "insertBindingCodes…" "/4<BaddRemoveDollars" \
  64.       "/3<BinsertDivider" "/8<I<BsurroundWithBullets"]
  65.     return [list build $ma Tcl::MenuProc "" $tclMenu]
  66. }
  67. menu::buildProc tclMenu menu::buildtclMenu
  68. menu::buildSome tclMenu
  69.  
  70. newPref v prefixString {# } Tcl
  71. newPref f wordWrap {0} Tcl
  72. newPref v funcExpr {^proc *([+-a-zA-Z0-9]+)} Tcl
  73. newPref v parseExpr {^proc *([+-a-zA-Z0-9]+)} Tcl
  74. newPref v wordBreak {(\$)?[\w:_]+} Tcl
  75. newPref v wordBreakPreface {([^\w:_\$]|.\$)} Tcl
  76. newPref f autoMark 0 Tcl
  77. newPref v stringColor green Tcl
  78. newPref v commentColor red Tcl
  79. newPref v keywordColor blue Tcl
  80. # Colour to use for Alpha's built in commands
  81. newPref v alphaKeyWordColor    none Tcl stringColorProc
  82. # Colour Tk commands
  83. newPref f recogniseTk 1 Tcl Tcl::_updateKeywords
  84. # Colour [incr Tcl] commands
  85. newPref f recogniseItcl 1 Tcl Tcl::_updateKeywords
  86. # Recognise and colour some common procedures 'lunion' etc.
  87. newPref f recognisePseudoTcl 1 Tcl Tcl::_updateKeywords
  88. # Indentation scheme for lines following one ending in a backslash
  89. newPref v indentSlashEndLines 1 Tcl "" indent::amounts varindex
  90. # Mark files structurally, recognising the special comments
  91. # entered by 'ctrl-3'
  92. newPref f structuralMarks 0 Tcl
  93. set Tcl::startPara {^(.*\{)?[ \t]*(#|$)}
  94. set Tcl::endPara {^(.*\})?[ \t]*(#|$)}
  95. set Tcl::commentRegexp {^[ \t]*#}
  96.  
  97. ## 
  98.  # -------------------------------------------------------------------------
  99.  # 
  100.  # "Tcl::_updateKeywords" --
  101.  # 
  102.  #  This proc now includes support for optional separate colorization of 
  103.  #  alpha commands. To use, set 'alphaKeyWordColor' to something other than 
  104.  #  'none' in the Tcl Mode Preferences dialog. -trf
  105.  # -------------------------------------------------------------------------
  106.  ##
  107. proc Tcl::_updateKeywords {args} {
  108.     set tclKeyWords {
  109.     after append array auto_execok auto_load auto_mkindex 
  110.     auto_reset beep binary break case catch cd clock close concat 
  111.     continue echo eof error eval exit expr fblocked fconfigure 
  112.     fcopy file fileevent flush for foreach format gets glob global 
  113.     history if incr info interp join lappend lindex linsert list 
  114.     llength load lrange lreplace ls lsearch lsort namespace open 
  115.     package pid pkg_mkIndex proc puts pwd read regexp regsub 
  116.     rename resource return scan seek set socket source split 
  117.     string subst switch tclMacPkgSearch tclPkgSetup tclPkgUnknown 
  118.     tell time trace unknown unset update uplevel upvar variable 
  119.     vwait while scancontext else elseif default
  120.     }
  121.     
  122.     set alphaKeyWords {
  123.     abortEm abbrev addAlphaChars addMenuItem addDef addArrDef 
  124.     AEBuild alertnote alphaHelp ascii askyesno backColor backSpace 
  125.     backwardChar backwardCharSelect backwardDeleteWord 
  126.     backwardWord balance beginningBufferSelect beginningLineSelect 
  127.     beginningOfBuffer beginningOfLine Bind blink breakIntoLines 
  128.     bringToFront buttonAlert capitalizeRegion capitalizeWord 
  129.     centerRedraw clear closeAll colors colorTriple copy cp 
  130.     createTagFile createTMark currentPosition cut decToHex 
  131.     deleteChar deleteMenuItem deleteModeBindings deleteSelection 
  132.     deleteWord describeBinding deleteText dialog dirs display 
  133.     displayMode dosc downcaseRegion downcaseWord dumpColors 
  134.     dumpMacro edit enableMenuItem endBufferSelect endKeyboardMacro 
  135.     endLineSelect endOfBuffer endOfLine enterSelection evaluate
  136.     eventHandler exchangePointAndMark execAbbrev execute 
  137.     executeKeyboardMacro fileInfo fileRemove find findAgain 
  138.     findAgainBackward findFile findInNextFile findTag float 
  139.     floatShowHide forwardChar forwardCharSelect forwardWord 
  140.     freeMem get_directory getAscii getChar getModifiers getColors 
  141.     getfile getFileInfo getGeometry getline getMainDevice getMark 
  142.     getNamedMarks getPathName getPos getScrap getSelect getText 
  143.     getTMarks getWinInfo goto gotoMark gotoTMark hexToDec icon 
  144.     icURL icGetPref icOpen insertAscii insertColorEscape 
  145.     insertFile insertMenu insertPathName insertText insertToTop 
  146.     isearch iterationCount jumpToRegister keyAscii keyCode 
  147.     killLine killWindow largestPrefix launch lineStart 
  148.     listBindings listpick lookAt markHilite markMenuItem 
  149.     matchBrace matchIt maxPos Menu message mkdir mousePos 
  150.     moveInsertionHere moveFile moveWin mtime nameFromAppl new 
  151.     nextLine nextLineSelect nextLineStart nextSentence nextWindow 
  152.     now oneSpace openLine otherPane pageBack pageForward pageSetup 
  153.     paste pointToRegister popd posToRowCol prefixChar previousLine 
  154.     prevLineSelect prevSentence prevWindow print processes prompt 
  155.     pushd putfile putScrap quit rectMarkHilite redo 
  156.     regModeKeywords removeArrDef removeDef removeFile removeMark 
  157.     removeMenu removeTMark replace replaceAll replace&FindAgain 
  158.     replaceString replaceText restoreVars revert rmdir rowColToPos 
  159.     rsearch save saveAs saveVars scrollDownLine scrollLeftCol 
  160.     scrollRightCol scrollUpLine search searchString select selEnd 
  161.     sendOpenEvent sendToBack setFileInfo setFontsTabs setMark 
  162.     setNamedMark setWinInfo shell shiftLeftRegion shiftRightRegion 
  163.     sizeWin sortMarks spacesToTabs specToPathName splitWindow 
  164.     startEscape startKeyboardMacro statusPrompt substituteVars 
  165.     switchTo tab tabsToSpaces tclFileCompletion tclResult 
  166.     thinkReference ticks toggleScrollbar traceFunc unascii unBind 
  167.     undo unfloat upcaseRegion upcaseWord version watchCursor wc 
  168.     winNames wrap wrapText xtclcmd yank zapInvisibles zoom
  169.     }
  170.     
  171.     set tkKeyWords {
  172.     bind bindtags button canvas checkbutton console destroy entry event focus 
  173.     font frame grab grid image menubutton pack place radiobutton raise 
  174.     scale scrollbar text tk tkwait toplevel winfo wm label listbox
  175.     menu
  176.     }
  177.     
  178.     set itclKeyWords {
  179.     @scope body class code common component configbody constructor define 
  180.     destructor hull 
  181.     import inherit itcl itk itk_component itk_initialize itk_interior 
  182.     itk_option iwidgets keep method private protected 
  183.     public
  184.     }
  185.     global TclmodeVars
  186.     # add Tk keywords
  187.     if {$TclmodeVars(recogniseTk)} {
  188.     set tclKeyWords [concat $tclKeyWords $tkKeyWords]
  189.     }
  190.     # add the [incr tcl] keywords
  191.     if {$TclmodeVars(recogniseItcl)} {
  192.     set tclKeyWords [concat $tclKeyWords $itclKeyWords]
  193.     }
  194.     if {$TclmodeVars(recognisePseudoTcl)} {
  195.     set tclKeyWords [concat $tclKeyWords "lunion lreverse lremove lunique car"]
  196.     }
  197.     # add user extras
  198.     global Tclwords
  199.     if {[info exists Tclwords]} {
  200.     set tclKeyWords [concat $tclKeyWords $Tclwords]
  201.     }
  202.     global Tclcmds
  203.     set Tclcmds { append array catch close concat continue elseif error
  204.     for foreach format lindex llength lrange lreplace lsearch lsort regexp 
  205.     regsub rename return string switch while }
  206.     if {$TclmodeVars(recogniseTk)} {
  207.     append Tclcmds {
  208.         tkButtonDown tkButtonEnter tkButtonInvoke tkButtonLeave 
  209.         tkButtonUp tkCancelRepeat tkCheckRadioInvoke tkDarken 
  210.         tkEntryAutoScan tkEntryBackspace tkEntryButton1 
  211.         tkEntryClosestGap tkEntryInsert tkEntryKeySelect 
  212.         tkEntryMouseSelect tkEntryNextWord tkEntryPaste 
  213.         tkEntryPreviousWord tkEntrySeeInsert tkEntrySetCursor 
  214.         tkEntryTranspose tkEventMotifBindings tkFDGetFileTypes 
  215.         tkFirstMenu tkFocusGroup_BindIn tkFocusGroup_BindOut 
  216.         tkFocusGroup_Create tkFocusGroup_Destroy tkFocusGroup_In 
  217.         tkFocusGroup_Out tkFocusOK tkListboxAutoScan 
  218.         tkListboxBeginExtend tkListboxBeginSelect tkListboxBeginToggle 
  219.         tkListboxCancel tkListboxDataExtend tkListboxExtendUpDown 
  220.         tkListboxMotion tkListboxSelectAll tkListboxUpDown tkMbButtonUp 
  221.         tkMbEnter tkMbLeave tkMbMotion tkMbPost tkMenuButtonDown 
  222.         tkMenuDownArrow tkMenuDup tkMenuEscape tkMenuFind 
  223.         tkMenuFindName tkMenuFirstEntry tkMenuInvoke tkMenuLeave 
  224.         tkMenuLeftArrow tkMenuMotion tkMenuNextEntry tkMenuNextMenu 
  225.         tkMenuRightArrow tkMenuUnpost tkMenuUpArrow tkMessageBox 
  226.         tkPostOverPoint tkRecolorTree tkRestoreOldGrab tkSaveGrabInfo 
  227.         tkScaleActivate tkScaleButton2Down tkScaleButtonDown 
  228.         tkScaleControlPress tkScaleDrag tkScaleEndDrag tkScaleIncrement 
  229.         tkScreenChanged tkScrollButton2Down tkScrollButtonDown 
  230.         tkScrollButtonUp tkScrollByPages tkScrollByUnits tkScrollDrag 
  231.         tkScrollEndDrag tkScrollSelect tkScrollStartDrag tkScrollToPos 
  232.         tkScrollTopBottom tkTabToWindow tkTearOffMenu tkTextAutoScan 
  233.         tkTextButton1 tkTextClosestGap tkTextInsert tkTextKeyExtend 
  234.         tkTextKeySelect tkTextNextPara tkTextNextPos tkTextNextWord 
  235.         tkTextPaste tkTextPrevPara tkTextPrevPos tkTextResetAnchor 
  236.         tkTextScrollPages tkTextSelectTo tkTextSetCursor 
  237.         tkTextTranspose tkTextUpDownLine tkTraverseToMenu 
  238.         tkTraverseWithinMenu tk_bisque tk_chooseColor tk_dialog 
  239.         tk_focusFollowsMouse tk_focusNext tk_focusPrev tk_getOpenFile 
  240.         tk_getSaveFile tk_messageBox tk_optionMenu tk_popup 
  241.         tk_setPalette tk_textCopy tk_textCut tk_textPaste
  242.     }
  243.     }
  244.     
  245.     if {$TclmodeVars(recogniseTk)} {
  246.     regModeKeywords -e {#} -c $TclmodeVars(commentColor) \
  247.       -s $TclmodeVars(stringColor) \
  248.       -k $TclmodeVars(keywordColor) Tcl $tclKeyWords 
  249.     # add this line if we can handle double 'magic chars'
  250.     #-m {tk} 
  251.     } else {
  252.     regModeKeywords -e {#} -c $TclmodeVars(commentColor) \
  253.       -s $TclmodeVars(stringColor) \
  254.       -k $TclmodeVars(keywordColor) Tcl $tclKeyWords 
  255.     }
  256.     if {$TclmodeVars(alphaKeyWordColor) != "none"} {
  257.     regModeKeywords -a -k $TclmodeVars(alphaKeyWordColor) Tcl $alphaKeyWords
  258.     }
  259. }
  260. # call it now
  261. Tcl::_updateKeywords
  262.  
  263. proc Tcl::MenuProc {menu item} {
  264.     switch -glob $item {
  265.     "traceThisProc" {
  266.         procs::traceProc [procs::findEnclosingName [getPos]]
  267.     }
  268.     "reformatProc" {
  269.         procs::reformatEnclosing [getPos]
  270.     }
  271.     "reloadProc" {
  272.         procs::loadEnclosing [getPos]
  273.     }
  274.     "findProcDefinition" {
  275.         procs::findDefinition
  276.     }
  277.     "quickFindProc" {
  278.         # use the status line
  279.         procs::quickFindDefn
  280.     }
  281.     "switch*" {
  282.         set v "[string tolower [string range $item 8 end]]Sig"
  283.         global $v
  284.         app::launchFore [set $v]
  285.     }
  286.     default {
  287.         eval $item
  288.     }
  289.     }
  290. }
  291. namespace eval tcltk {}
  292.  
  293. proc tcltk::menuProc {menu item} {
  294.     switch $item {
  295.     "evaluateRemotely" {
  296.         global evaluateRemotely
  297.         set evaluateRemotely [expr {1 - $evaluateRemotely}]
  298.     }
  299.     default {
  300.         global tclshSig
  301.         set cmd [getline "Please enter the script to send to tcl-tk"]
  302.         set res [AEBuild -r -t 30000 '$tclshSig' misc dosc ---- "“$cmd”"]
  303.         alertnote "Result was '$res'"
  304.     }
  305.     }
  306. }
  307.  
  308. proc evaluateRemoteSynchronise {args} {
  309.     global evaluateRemotely tclMenu
  310.     catch {markMenuItem "tcl-tk" evaluateRemotely $evaluateRemotely}
  311.     if {$evaluateRemotely} {
  312.     if {[info commands notRemoteEvaluate] == ""} {
  313.         rename evaluate notRemoteEvaluate
  314.         ;proc evaluate {} {remoteEvaluate}
  315.     }
  316.     menu::replaceRebuild tclMenu "•320"
  317.     } else {
  318.     if {[info commands notRemoteEvaluate] != ""} {
  319.         rename evaluate {}
  320.         rename notRemoteEvaluate evaluate
  321.     }
  322.     menu::replaceRebuild tclMenu "•269"
  323.     }
  324. }
  325.  
  326. proc remoteEvaluate {} {
  327.     global tclshSig
  328.     app::ensureRunning $tclshSig
  329.     set t [getSelect]
  330.     catch {dosc -c '${tclshSig}' -s $t} r
  331.     message "Remote reply: $r"
  332. }
  333.  
  334. # ◊◊◊◊ Quick Find Proc… ◊◊◊◊ #
  335.  
  336. proc procs::quickFindDefn {} {
  337.     Tcl::DblClickHelper [prompt::statusLineComplete "proc" procs::complete]
  338. }
  339.  
  340. if {[info tclversion] < 8.0} {
  341.     proc procs::complete {pref} {
  342.     return [info commands ${pref}*]
  343.     }
  344. } else {
  345.     proc procs::complete {pref} {
  346.     if {[regexp {(.*)([^:]+)$} $pref "" start tail]} {
  347.         set cmds [info commands ${pref}*]
  348.         foreach child [namespace children ::$start] {
  349.         if {[string match "::${tail}*" $child]} {
  350.             foreach cmd [info commands ${start}${child}::*] {
  351.             lappend cmds [string trimleft $cmd :]
  352.             }
  353.         }
  354.         }
  355.         return $cmds
  356.     } else {
  357.         return [info commands ${pref}*]
  358.     }
  359.     }
  360. }
  361.  
  362. # ◊◊◊◊ electric behaviour ◊◊◊◊ #
  363. proc Tcl::electricLeft {} {
  364.     if {[literalChar]} { insertText "\{"; return }
  365.     set pat "\}\[ \t\r\n\]*(else(if)?)\[ \t\r\n\]*\$"
  366.     set p [getPos]
  367.     if { [set res [findPatJustBefore "\}" "$pat" $p word]] == "" } { 
  368.     insertText "\{"
  369.     return
  370.     }
  371.     # we have an if/else(if)/else
  372.     switch -- $word {
  373.     "else" {
  374.         replaceText [lindex $res 0] $p "\} $word \{\r"
  375.         bind::IndentLine
  376.     }
  377.     "elseif" {
  378.         replaceText [lindex $res 0] $p "\} $word \{"
  379.     }
  380.     }
  381. }
  382.     
  383. proc Tcl::electricRight {} {
  384.     if {[literalChar]} { insertText "\}"; return }
  385.     set p [getPos]
  386.     if { [regexp "\[^ \t\]" [getText [lineStart $p] $p]] } {
  387.     insertText "\}"
  388.     blink [matchIt "\}" [pos::math $p - 1]]
  389.     return
  390.     }
  391.     set start [lineStart $p]
  392.     insertText "\}"
  393.     createTMark tcl_er [getPos]
  394.     backwardChar
  395.     bind::IndentLine
  396.     gotoTMark tcl_er ; removeTMark tcl_er
  397.     bind::CarriageReturn
  398.     blink [matchIt "\}" [pos::math $start - 1]]
  399. }
  400.  
  401. ## 
  402.  # -------------------------------------------------------------------------
  403.  # 
  404.  # "Tcl::correctIndentation" --
  405.  # 
  406.  #  Returns the correct indentation for the line containing $pos, if that
  407.  #  line were to contain ordinary characters only.  It is the 
  408.  #  responsibility of the calling procedure to ensure that if we are to
  409.  #  insert/have a line already, that that information is taken into
  410.  #  account, by passing in the argument 'next'
  411.  # -------------------------------------------------------------------------
  412.  ##
  413. proc Tcl::correctIndentation {pos {next ""}} {
  414.     global indent_amounts indentSlashEndLines
  415.     # preliminaries
  416.     if {[pos::compare [set beg [lineStart $pos]] == [minPos]]} { return 0 }
  417.     # if the current line is a comment, we have to check some
  418.     # special cases
  419.     if {[set next [string index $next 0]] == "\#"} {
  420.     set p [prevLineStart $beg]
  421.     if {[catch {set p [search -s -f 0 -r 1 -i 0 -m 0 "^\[ \t\]*\[^ \t\r\n\]" \
  422.       [pos::math $beg - 1]]}]} {
  423.         # check for search bug at beginning of file.
  424.         if {[pos::compare $p == [minPos]]} {
  425.         if {[getText [minPos] [pos::math [minPos] + 2]] == "\#\#"} {
  426.             return 1
  427.         }
  428.         }
  429.         return 0
  430.     }
  431.     set prev [pos::math [lindex $p 1] - 1]
  432.     set p [lindex $p 0]
  433.     if {[lookAt $prev] != "\#" || ($beg == [minPos])} {
  434.         # not a comment, so indent with code
  435.     } else {
  436.         set lwhite [posX $prev]
  437.         # it's a comment
  438.         if {[getText $prev [pos::math $prev + 2]] == "\#\#" && \
  439.           [lookAt [pos::math $prev + 2]] != "\#" } {
  440.         
  441.         # it's a comment paragraph
  442.         incr lwhite 
  443.         }
  444.     }
  445.     }
  446.     if {![info exists lwhite]} {
  447.     if ![catch {search -s -f 0 -r 1 -i 0 -m 0 "^\[ \t\]*\[^\# \t\r\n\]" [pos::math $beg - 1]} lst] {
  448.         # Find the last non-comment line and get its leading whitespace    
  449.         set lwhite [posX [pos::math [lindex $lst 1] - 1]]
  450.         set pe1 [lookAt [pos::math $beg - 2]]
  451.         set lst [lindex $lst 0]
  452.         set lastC [lookAt [lindex [search -s -f 0 -r 1 -i 0 -m 0 "\[^ \t\r\n\]" [pos::math [nextLineStart $lst] - 1]] 0]]
  453.         if {$next == "\}"} {
  454.         incr lwhite $indent_amounts(-2)
  455.         set pe2 [lookAt [pos::math [prevLineStart $beg] - 2]]
  456.         if {$pe1 == "\\"} {
  457.             incr lwhite $indent_amounts(1)
  458.         } else {
  459.             if {$pe2 == "\\"} {
  460.             incr lwhite $indent_amounts(-1)
  461.             }
  462.         }
  463.         if {$lastC == "\{"} {incr lwhite $indent_amounts(2)}    
  464.         } else { 
  465.         if {$pe1 == "\\"} {
  466.             if {[lookAt [pos::math [prevLineStart $beg] - 2]] != "\\"} {
  467.             incr lwhite $indent_amounts($indentSlashEndLines)
  468.             }
  469.         } else {
  470.             if {$lastC == "\{"} {incr lwhite $indent_amounts(2)}    
  471.             if {[lookAt [pos::math $lst - 2]] == "\\"} {
  472.             incr lwhite $indent_amounts(-$indentSlashEndLines)
  473.             }
  474.         }
  475.         }
  476.     } else {
  477.         # basically failed in all the above, so keep current indentation
  478.         set lwhite [posX [text::firstNonWsLinePos $beg]]
  479.     }
  480.     }
  481.     return [expr {$lwhite > 0 ? $lwhite : 0}]
  482. }
  483.  
  484. ## 
  485.  # -------------------------------------------------------------------------
  486.  #   
  487.  # "Tcl::indentLine" --
  488.  #  
  489.  #  Indentation for Tcl mode.  Better and faster than the generic procedure
  490.  # -------------------------------------------------------------------------
  491.  ##
  492. proc Tcl::indentLine {} {
  493.     set beg [lineStart [getPos]]
  494.     set text [getText $beg [nextLineStart $beg]]
  495.     regexp "^\[ \t\]*" $text white
  496.     set next [pos::math $beg + [string length $white]]
  497.     set lwhite [Tcl::correctIndentation [getPos] [lookAt $next]]
  498.     
  499.     set lwhite [text::indentOf $lwhite]
  500.     if {$white != $lwhite} {
  501.     replaceText $beg $next $lwhite
  502.     }
  503.     goto [pos::math $beg + [string length $lwhite]]
  504. }
  505. # ◊◊◊◊ Tcl Menu support ◊◊◊◊ #
  506.  
  507. proc procs::reformatEnclosing {pos} {
  508.     set p [procs::findEnclosing $pos "proc|body|configbody" 1]
  509.     eval select $p
  510.     ::indentRegion
  511. }
  512.  
  513. proc procs::loadEnclosing {pos} {
  514.     if {[catch {procs::findEnclosing $pos "proc|body|configbody" 1} p]} {
  515.     evaluateLine $pos
  516.     } else {
  517.     eval select $p
  518.     uplevel \#0 evaluate    
  519.     }
  520.     goto $pos
  521. }
  522.  
  523. proc procs::findDefinition {} {
  524.     if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
  525.     set func [listpick -L $sel -p {Proc?} [lsort -ignore [info procs]]]
  526.     } else {
  527.     set func [listpick -p {Proc?} [lsort -ignore [info procs]]]
  528.     }
  529.     
  530.     editMark [procs::find $func] $func
  531. }
  532.  
  533. proc insertMenuCodes {} {
  534.     insertText [prompt::getAKey]
  535. }
  536.  
  537. proc insertBindingCodes {} {
  538.     beep
  539.     keyCode
  540. }
  541.  
  542. proc addRemoveDollars {} {
  543.     set p [getPos]
  544.     backwardWord
  545.     if {[lookAt [getPos]] == "\$"} {
  546.     deleteChar
  547.     goto [pos::math $p -1]
  548.     } else {
  549.     insertText "\$"
  550.     goto [pos::math $p +1]
  551.     }
  552. }
  553.  
  554. ## 
  555.  # -------------------------------------------------------------------------
  556.  # 
  557.  # "insertDivider" --
  558.  # 
  559.  #  Modified from Vince's original to allow you to just select part of
  560.  #  an already written comment and turn it into a Divider. -trf
  561.  # -------------------------------------------------------------------------
  562.  ##
  563. proc insertDivider {} {
  564.     if {[isSelection]} {
  565.     set enfoldThis [getSelect]
  566.     beginningOfLine
  567.     killLine
  568.     insertText "# ◊◊◊◊ $enfoldThis ◊◊◊◊ #"
  569.     return
  570.     } 
  571.     elec::Insertion "# ◊◊◊◊ •• ◊◊◊◊ #"
  572. }
  573.  
  574. # vince's versions seems to have been left out, so here's mine -trf
  575. # If there is a selection, it get surrounded, if there is no selection,
  576. # but the cursor is touching the end of a word, it gets surrounded. 
  577. # Otherwise, we get a template (could not come up with a "stop beyond")
  578. proc surroundWithBullets {} {
  579.     if {[pos::compare [getPos] == [selEnd]]} {
  580.     set p [getPos]
  581.     backwardWord 
  582.     set sw [getPos]
  583.     forwardWord 
  584.     set ew [getPos]
  585.     goto $p
  586.     if {[pos::compare $p == $ew]} {
  587.         select $sw $ew
  588.     } 
  589.     }
  590.     if {[isSelection]} {
  591.     set enfoldThis [getSelect]
  592.     deleteSelection
  593.     insertText "•$enfoldThis•"
  594.     return
  595.     } 
  596.     insertText "••"
  597.     backwardChar
  598.     elec::Insertion "•replace-this•"
  599. }
  600. # ◊◊◊◊ Info providers ◊◊◊◊ #
  601. #===============================================================================
  602.  
  603. ## 
  604.  # -------------------------------------------------------------------------
  605.  # 
  606.  # "TclOptionTitlebar" --
  607.  # 
  608.  #  Add corresponding extension/non-extension files.
  609.  # -------------------------------------------------------------------------
  610.  ##
  611. proc Tcl::OptionTitlebar {} {
  612.     if [package::active smarterSource] {
  613.     set n [win::CurrentTail]
  614.     if {[set a [string first + $n]] != -1} {
  615.         return "[string range $n 0 [expr $a -1]][file extension $n]"
  616.     } else {
  617.         global tclExtensionsFolder
  618.         pushd $tclExtensionsFolder
  619.         set f [glob -nocomplain "[file root $n]+*[file extension $n]"]
  620.         popd
  621.         return $f
  622.     }
  623.     } else {
  624.     return ""
  625.     }
  626. }
  627.  
  628. proc Tcl::DblClick {from to shift option control} {
  629.     
  630.     # if cmd and cntrl were pressed, we look to select part of
  631.     # a combination word (less any leading dollar sign) -trf
  632.     if {$control != 0} {
  633.     set clickedPos [getPos]    
  634.     if {[lookAt $from] == "\$"} {
  635.         set from [pos::math $from + 1]
  636.     } 
  637.     set sel_start $clickedPos 
  638.     set    selStartNotDetermined 1
  639.     while {$selStartNotDetermined && ([pos::math $sel_start > $from])} {
  640.         set char [lookAt $sel_start] 
  641.         if {[regexp {_} $char]} {
  642.         set sel_start [pos::math $sel_start + 1]
  643.         set selStartNotDetermined 0
  644.         } elseif {[regexp {[A-Z]} $char]} {
  645.         set selStartNotDetermined 0
  646.         } else {
  647.         set sel_start [pos::math $sel_start -1]
  648.         } 
  649.     }
  650.     set sel_end   $clickedPos 
  651.     set    selEndNotDetermined 1
  652.     while {$selEndNotDetermined && ([pos::math $sel_end <= $to])} {
  653.         set char [lookAt $sel_end] 
  654.         if {[regexp "\[A-Z_ \t\r\]" $char]} {
  655.         set selEndNotDetermined 0
  656.         } else {
  657.         set sel_end [pos::math $sel_end + 1]
  658.         } 
  659.     }
  660.     select $sel_start $sel_end 
  661.     return
  662.     } 
  663.     
  664.     # otherwise, we try to impart some extra info
  665.     select $from $to
  666.     
  667.     if {[catch {Tcl::DblClickHelper [getSelect]}]} {
  668.     message "No docs $shift $control $option"
  669.     }
  670. }
  671.  
  672.  
  673. # Now finds commands in Alpha Commands,
  674. # which has a <cr> immediately after them, e.g. beep, ticks.
  675. proc Tcl::DblClickHelper {text} {
  676.     global HOME auto_index auto_path
  677.     # Is it a loadable proc?
  678.     if {[string length [set f [procs::find $text]]]} {
  679.     if {[editMark $f $text]} {
  680.         # some marking schemes commonly used for Tcl modes
  681.         goto [lindex [search -s -f 1 -r 1 -m 0 -- "proc\[ \t\]+${text}" [minPos]] 0]
  682.     }
  683.     return
  684.     }
  685.     
  686.     if {[info exists "auto_index($text)"]} {
  687.     if {[editMark "$auto_index($text)" $text]} {
  688.         # some marking schemes commonly used for Tcl modes
  689.         goto [lindex [search -s -f 1 -r 1 -m 0 -- "proc\[ \t\]+${text}" [minPos]] 0]
  690.     }
  691.     return
  692.     }
  693.     # Is it a built-in Alpha command?
  694.     set lines [grep "^• $text\( |$)" [file join $HOME Help "Alpha Commands"]]
  695.     if {[string length $lines]} {
  696.     if {[catch {editMark [file join $HOME Help "Alpha Commands"] $text}]} {
  697.         # mark failed for some reason, but we have the line number
  698.         # anyway.
  699.         file::openQuietly [file join $HOME Help "Alpha Commands"]
  700.         goto [rowColToPos [string trimright [lindex [lindex [split $lines "\n"] 1] 3] :] 0]
  701.     }
  702.     setWinInfo read-only 1
  703.     return
  704.     }
  705.     # Is it a core Tcl command?
  706.     set lines [grep "^     $text -" [file join $HOME Help "Tcl Commands"]]
  707.     if {[string length $lines]} {
  708.     if {[catch {editMark [file join $HOME Help "Tcl Commands"] $text}]} {
  709.         # mark failed for some reason, but we have the line number
  710.         # anyway.
  711.         file::openQuietly [file join $HOME Help "Tcl Commands"]
  712.         goto [rowColToPos [string trimright [lindex [lindex [split $lines "\n"] 1] 3] :] 0]
  713.     }
  714.     setWinInfo read-only 1
  715.     return
  716.     }
  717.     # Is it a global variable?
  718.     if {[llength [info globals [string trimleft $text {$}]]]==1} {
  719.     showVarValue [string trimleft $text {$}]
  720.     return
  721.     }
  722.     # (becoming desperate) is it a mark in the current file?
  723.     if {[lsearch [getNamedMarks -n] ${text}] != -1} {
  724.     gotoMark $text
  725.     return
  726.     }
  727.     error ""
  728. }
  729.  
  730. #############################################################################
  731. #  Report the current value of a global variable, chosen interactively
  732. #  from a list of all active variables.
  733. #
  734. #  If the variable is an array, or its value is too big to fit in an 
  735. #  alertnote, then its contents are listed in a new window, otherwise 
  736. #  the variable's value is displayed in an alertnote.
  737. #
  738. proc getVarValue {} {
  739.     set def [getText [getPos] [selEnd]]
  740.     set var [getVarFromList $def]
  741.     if {[string length $var] == 0} return
  742.     showVarValue $var
  743. }
  744.  
  745. if {[info tclversion] < 8.0} {
  746.     
  747. proc getVarFromList {{def ""}} {
  748.     return [listpick -p {Which var?} -L $def [lsort -ignore [info globals]]]
  749. }
  750.     
  751. } else {
  752.     
  753.     proc getVarFromList {{def ""}} {
  754.     set ns "[namespace qualifiers $def]"
  755.     set def [namespace tail $def]
  756.     
  757.     set items {}
  758.     foreach var [info vars "${ns}::*"] {
  759.         lappend items [namespace tail $var]
  760.     }
  761.     foreach space [namespace children $ns] {
  762.         lappend items "[namespace tail $space]::"
  763.     }
  764.     
  765.     set items [concat "::" [lsort -ignore $items]]
  766.     set var [listpick -p "Which var in namespace ${ns}::?" -L $def $items]
  767.     if {$var == "::"} {
  768.         set var [getVarFromList $ns]
  769.     } elseif {[namespace qualifiers $var] != ""} {
  770.         set var [getVarFromList "${ns}::${var}"]
  771.     } else {
  772.         set var "${ns}::${var}"
  773.     }
  774.     return $var
  775.     }
  776. }
  777.  
  778. #############################################################################
  779. #  Report the current value of a global variable, chosen interactively
  780. #  from a list of all active variables.
  781. #
  782. #  If the variable is an array, or its value is too big to fit in an 
  783. #  alertnote, then its contents are listed in a new window, otherwise 
  784. #  the variable's value is displayed in an alertnote.
  785. #
  786. proc showVarValue {var} {
  787.     global $var
  788.     if {![catch {set $var} value]} {
  789.         viewValue $var $value
  790.     return
  791.     } else {
  792.     regsub -all : $var . var1
  793.         new -n "* $var1 *"
  794.         listArray $var
  795.     }
  796.     # if 'shrinkWindow' is loaded, call it to trim the output window.
  797.     catch {shrinkWindow 2}
  798.     winReadOnly
  799. } 
  800.  
  801. #############################################################################
  802. #  List the name and value of each element of the array $arrName.
  803. #  (Convenient to use as a shell command.)
  804. #
  805. proc listArray {arrName} {
  806.     global $arrName
  807.     set lines {}
  808.     if {![catch {info vars $arrName}]} {
  809.         foreach nm [array names $arrName] {
  810.             # modified to handle odd named arrays -trf
  811.             set val [eval set \{$arrName\($nm\)\}]
  812.             append lines "\r\"$nm\"\t\{$val\}"
  813.         }
  814.         insertText $lines
  815.     } else {
  816.         alertnote "\"$arrName\" doesn't exist in this context"
  817.     }
  818. }
  819.  
  820. # ◊◊◊◊ Marking ◊◊◊◊ #
  821. # note: I put these procs in this order to reflect where you go to activate
  822. #  them, i.e. parseFuncsTcl via 'braces' pop-up, which is on top of the 
  823. # 'M' pop-up (invokes Tcl::MarkFile).
  824.  
  825. ## 
  826.  # -------------------------------------------------------------------------
  827.  #     
  828.  # "Tcl::parseFuncs" --
  829.  #    
  830.  #    This proc is called    by the "braces"    pop-up.    It returns a dynamically
  831.  #    created, alphabetical, list of    "pseudo-marks".
  832.  #    
  833.  #    Author:    Tom    Fetherston
  834.  # -------------------------------------------------------------------------
  835.  ## called by the "{}" button
  836. proc Tcl::parseFuncs {} {
  837.     global TclmodeVars
  838.     set end [maxPos]
  839.     set pos [minPos]
  840.     set l {}
  841.     set markExpr "^\[ \t\]*((itcl(::|_))?class|body|proc|method|body)\[ \t\]"
  842.     set appearanceList {}
  843.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  844.     set start [lindex $res 0]
  845.     set end [nextLineStart $start]
  846.     set t [getText $start $end]
  847.     append t "\}"
  848.     switch [lindex $t 0] {
  849.         "proc" {
  850.         set argLabel {}
  851.         append argLabel [set word [lindex $t 1] ]
  852.         #get the list of arguments
  853.         set argsList [lindex $t 2]
  854.         if {[llength $argsList] > 0} {
  855.             append argLabel " \{"
  856.             foreach arg $argsList {
  857.             if {[llength $arg] == 2 } {
  858.                 append argLabel "¿"
  859.             } elseif {[set arg] != "args"} {
  860.                 append argLabel "•"
  861.             } else {
  862.                 append argLabel "…"
  863.             }
  864.             }
  865.             append argLabel "\}"                    
  866.         } 
  867.         }
  868.     }
  869.     if {[info exists cnts($word)]} {
  870.         # This section handles duplicate. i.e., overloaded names
  871.         set cnts($word) [expr $cnts($word) + 1]
  872.         set tailOfTag($word) " ($cnts($word) of $cnts($word))"
  873.         # we want the tag to point to its last occurence 
  874.         # because in Tcl, that proc will be 'in-force' when the
  875.         # file is loaded.
  876.         set indx($word) [lineStart [pos::math $start - 1]]
  877.     } else {
  878.         #SO do: remember the following
  879.         set cnts($word) 1
  880.         # if this is the only occurence of this proc, remember where it starts
  881.         set indx($word) [lineStart [pos::math $start - 1]]
  882.     }
  883.     #associate name and tag
  884.     set tag($word) $argLabel
  885.     
  886.     #advance pos to where we want to start the next search from
  887.     set pos $end
  888.     }
  889.     
  890.     set rtnRes {}
  891.     
  892.     if {[info exists indx]} {
  893.     foreach hn [lsort -ignore [array names indx]] {
  894.         set next [nextLineStart $indx($hn)]
  895.         set completeTag [set tag($hn)]
  896.         if {[info exists tailOfTag($hn)]} {
  897.         append completeTag [ set tailOfTag($hn) ]
  898.         }
  899.         
  900.         lappend rtnRes $completeTag $next
  901.     }
  902.     }
  903.     return $rtnRes 
  904. }
  905.  
  906. # called by the "M" button
  907. proc Tcl::MarkFile {} {
  908.     global structuralMarks
  909.     set end [maxPos]
  910.     set pos [minPos]
  911.     set l {}
  912.     if {$structuralMarks} {
  913.     set markExpr {^;?[     ]*((itcl(::|_))?class|namespace eval|proc|method|(config)?body|# ◊◊◊◊)[     ]}
  914.     } else {
  915.     set markExpr {^;?[     ]*((itcl(::|_))?class|namespace eval|proc|method|(config)?body)[     ]}
  916.     }
  917.     set class ""
  918.     set hasMarkers 0
  919.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  920.     set start [lindex $res 0]
  921.     set end [nextLineStart $start]
  922.     set t [string trim [getText $start $end] ";"]
  923.     append t "\}"
  924.     if {[catch {lindex $t 0}]} {
  925.         # wasn't a well formed list
  926.         set pos $end
  927.         continue
  928.     }
  929.     switch -glob [lindex $t 0] {
  930.         "proc" -
  931.         "configbody" { set text [lindex $t 1] }
  932.         "method" { set text ${class}::[lindex $t 1] }
  933.         "body" { 
  934.         regexp {[a-zA-Z_][a-zA-Z_/0-9]*::[a-zA-Z_][a-zA-Z_/0-9]* } \
  935.           "[lindex $t 1] " text
  936.         }
  937.         "namespace" {
  938.         set ns [lindex $t 2]
  939.         set text "${ns} 111" 
  940.         }
  941.         "*class" { 
  942.         set class [lindex $t 1]
  943.         set text "${class} 000" 
  944.         }
  945.         "#" { 
  946.         regexp "# ◊◊◊◊ (.*) ◊◊◊◊" $t all text
  947.         if {[regexp "^(    )|(    )# ◊◊◊◊ " $t]} {
  948.             set text " •$text"
  949.         } else {
  950.             set text "•$text"
  951.         }                 
  952.         set hasMarkers 1
  953.         }
  954.     }
  955.     set pos $end
  956.     if {$structuralMarks} {
  957.         lappend asEncountered $text
  958.         set arr inds
  959.     } else {
  960.         if {[string index $t 0] == ";"} {
  961.         set arr iinds
  962.         } else {
  963.         set arr inds
  964.         }
  965.     }
  966.     set ${arr}($text) [lineStart [pos::math $start - 1]]
  967.     }
  968.     
  969.     set already ""
  970.     set class "#"
  971.     foreach arr {inds iinds} {
  972.     if {[info exists $arr]} {
  973.         if {$arr == "iinds"} {
  974.         setNamedMark "-" 0 0 0
  975.         }
  976.         if {$structuralMarks} {
  977.         set order $asEncountered
  978.         } else {
  979.         set order [lsort -ignore [array names $arr]]
  980.         }
  981.         foreach f $order {
  982.         if {[set el [set ${arr}($f)]] != 0} {
  983.             set next [nextLineStart $el]
  984.         } else {
  985.             set next 0
  986.         } 
  987.         
  988.         if { [string first "000" $f] != -1 } {
  989.             set ff "Class '[set class [lindex $f 0]]'"
  990.         } elseif { [string first "111" $f] != -1 } {
  991.             set ff "Namespace '[set class [lindex $f 0]]'"
  992.         } elseif { [string first "${class}::" $f] != -1 } {
  993.             set ff [string range $f [string length $class] end]
  994.         } else {
  995.             set ff $f
  996.         }
  997.         while { [lsearch -exact $already $ff] != -1 } {
  998.             set ff "$ff "
  999.         }
  1000.         lappend already $ff
  1001.         if {$hasMarkers && ![string match "•*" $ff] } {
  1002.             set ff " $ff"
  1003.         } 
  1004.         setNamedMark $ff $el $next $next
  1005.         }
  1006.     }
  1007.     }
  1008. }
  1009.  
  1010. # ◊◊◊◊ Misc. ◊◊◊◊ #
  1011.  
  1012. ## 
  1013.  # -------------------------------------------------------------------------
  1014.  # 
  1015.  # "bind::tclContinueComment" --
  1016.  # 
  1017.  #  exploits a "feature" in the code that makes a new line a comment whenever 
  1018.  #  you are 'inside' a comment. This proc puts a pound sign at the end of the 
  1019.  #  current line, backsteps, and creates a new line. With the pound sign 
  1020.  #  present you are considered to be in a comment, so the bind::CarriageReturn 
  1021.  #  in the proc, and any subsequent bind::CarriageReturn called by a press of  
  1022.  #  the return key will provide another comment line automatically until the 
  1023.  #  pound sign at the end of the line is removed (killLine is handy for this).
  1024.  # -------------------------------------------------------------------------
  1025.  ##
  1026. proc bind::tclContinueComment {} {
  1027.     insertText {#}
  1028.     backwardChar
  1029.     bind::CarriageReturn
  1030. }
  1031. Bind '\r' <c> bind::tclContinueComment Tcl
  1032.  
  1033. proc evaluateLine { pos } {
  1034.     goto $pos
  1035.     beginningLineSelect
  1036.     endLineSelect
  1037.  
  1038.     uplevel \#0 evaluate
  1039.  
  1040. }
  1041.  
  1042.  
  1043.  
  1044. #◊◊◊◊> 
  1045.  
  1046.  
  1047.  
  1048. evaluateRemoteSynchronise
  1049.  
  1050.